home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / bbsutil / dlx70bbs.zip / DLX70SRC.ZIP / DATABASE.PAS < prev    next >
Pascal/Delphi Source File  |  1994-01-19  |  11KB  |  340 lines
  1. {$debug-}
  2. {$line-}
  3.  
  4. {$include: 'types.int'}
  5. {$include: 'globals.int'}
  6. {$include: 'utils.int'}
  7. {$include: 'database.int'}
  8.  
  9. IMPLEMENTATION OF database;
  10.  
  11. USES types,globals,utils;
  12.  
  13. {DLX Bulletin Board System V7.0
  14.  
  15.  FREEWARE NOTICE
  16.  
  17.  DLX V7.0 is placed in the public domain by its author, Richard Gillmann.
  18.  Anyone who wishes to may run the program, copy it, or modify it for
  19.  any purpose, including commercial gain.}
  20.  
  21. {***Interface to the PASASM assembler utilities package***}
  22. {$include: 'pasasm.int'}
  23.  
  24. procedure closegl;
  25. begin
  26.   f_globals.trap:=true;
  27.   f_globals.errs:=0;
  28.   assign(f_globals,globs);
  29.   rewrite(f_globals);
  30.   if f_globals.errs=0 then
  31.     writeln(f_globals,number_of_calls:-20,' {number of calls}');
  32.   if f_globals.errs=0 then
  33.     writeln(f_globals,last_new_user:-20,' {last new user number}');
  34.   if f_globals.errs=0 then
  35.     writeln(f_globals,mem_avl:-20,' {bytes in heap}');
  36.   close(f_globals);
  37. end {closegl};
  38.  
  39. procedure db_close_all;
  40. var
  41.   i : integer;
  42.   pm : pubmail_ptr;
  43. begin
  44. {globals}
  45.   closegl;
  46. {members}
  47.   close(f_members);
  48. {userlog}
  49.   close(f_userlog);
  50. end {db_close_all};
  51.  
  52. procedure db_update_all;
  53. begin
  54.   last_save:=jt;
  55.   db_close_all;
  56. {members}
  57.   f_members.mode:=direct;
  58.   f_members.trap:=true;
  59.   f_members.errs:=0;
  60.   assign(f_members,members);
  61.   reset(f_members);
  62.   members_io_flag:=getting;
  63. {userlog}
  64.   f_userlog.mode:=direct;
  65.   f_userlog.trap:=true;
  66.   f_userlog.errs:=0;
  67.   assign(f_userlog,ulog);
  68.   rewrite(f_userlog);
  69.   userlog_io_flag:=putting;
  70. end {db_update_all};
  71.  
  72. function dbg_member{mem : integer; var where : member_record} {boolean};
  73. begin
  74.   dbg_member:=true;
  75.   if mem<1 or else mem>largest_member_number then
  76.     dbg_member:=false
  77.   else
  78.     [if members_io_flag<>getting or else f_members.errs<>0 then
  79.        [close(f_members);
  80.         f_members.mode:=direct;
  81.         f_members.trap:=true;
  82.         f_members.errs:=0;
  83.         assign(f_members,members); reset(f_members);
  84.         members_io_flag:=getting];
  85.      if f_members.errs<>0 then
  86.        dbg_member:=false
  87.      else
  88.        [seek(f_members,mem);
  89.         if f_members.errs=0 then
  90.           [readln(f_members,member_internal_buffer);
  91.            movel(adr member_internal_buffer,adr where,member_length)]
  92.         else
  93.            dbg_member:=false]];
  94. end {dbg_member};
  95.  
  96. procedure dbp_member{mem : integer; const where : member_record};
  97. begin
  98.   if mem<1 or else mem>largest_member_number+1 then
  99.     return
  100.   else
  101.     [movel(adr where,adr member_buffer,member_length);
  102.      if mem<=member_index_top then
  103.        [member_index^[mem].active:=(member_buffer.active[1]='T');
  104.         member_index^[mem].gender[1]:=member_buffer.gender[1];
  105.         member_index^[mem].pref[1]:=member_buffer.pref[1];
  106.         member_index^[mem].age:=ivalue(member_buffer.age)];
  107.      movel(adr member_buffer,adr member_internal_buffer,member_length);
  108.      if members_io_flag<>putting or else f_members.errs<>0 then
  109.        [close(f_members);
  110.         f_members.mode:=direct;
  111.         f_members.trap:=true;
  112.         f_members.errs:=0;
  113.         assign(f_members,members); rewrite(f_members);
  114.         members_io_flag:=putting];
  115.      if f_members.errs=0 then seek(f_members,mem);
  116.      if f_members.errs=0 then writeln(f_members,member_internal_buffer)];
  117. end {dbp_member};
  118.  
  119. procedure dbg_userlog{dex : integer; var where : member_record};
  120. begin
  121.   if dex<1 or else dex>userlog_entries then
  122.     fillc(adr where,userlog_length,' ')
  123.   else
  124.     [if userlog_io_flag<>getting then
  125.        [close(f_userlog);
  126.         f_userlog.mode:=direct;
  127.         f_userlog.trap:=true;
  128.         f_userlog.errs:=0;
  129.         assign(f_userlog,ulog); reset(f_userlog);
  130.         userlog_io_flag:=getting];
  131.      seek(f_userlog,dex);
  132.      readln(f_userlog,userlog_internal_buffer);
  133.      f_userlog.errs:=0;
  134.      movel(adr userlog_internal_buffer,adr where,userlog_length)];
  135. end {dbg_userlog};
  136.  
  137. procedure dbp_userlog{dex : integer; const where : member_record};
  138. begin
  139.   if dex<1 or else dex>userlog_entries+1 then
  140.     return
  141.   else
  142.     [movel(adr where,adr userlog_internal_buffer,userlog_length);
  143.      if userlog_io_flag<>putting then
  144.        [close(f_userlog);
  145.         f_userlog.mode:=direct;
  146.         f_userlog.trap:=true;
  147.         f_userlog.errs:=0;
  148.         assign(f_userlog,ulog); rewrite(f_userlog);
  149.         userlog_io_flag:=putting];
  150.      seek(f_userlog,dex);
  151.      writeln(f_userlog,userlog_internal_buffer);
  152.      f_userlog.errs:=0];
  153. end {dbp_userlog};
  154.  
  155. procedure pad(vars str : lstring);
  156. var
  157.   i : integer;
  158. begin
  159.   i:=ord(str.len);
  160.   if i<screen_cols-2 then
  161.     fillsc(ads str[i+1],wrd(screen_cols-2-i),' ');
  162.   str[0]:=chr(screen_cols-2);
  163. end {pad};
  164.  
  165. function dbp_pubmail{p : para; d : char} {boolean};
  166. var
  167.   h,n : integer;
  168.   str : lstring(ord(index_length));
  169.   p2 : para;
  170. begin
  171.   copylst(pbd,str); concat(str,q[wx].pm^.letter);
  172.   h:=mail_zopen(str); {DATA}
  173.   if h<=0 then [q[wx].dos_err:=-h; dbp_pubmail:=false; return];
  174.   n:=0;
  175.   while p<>nill do
  176.     [pad(p^.msg); mail_writeln(h,p^.msg);
  177.      p2:=p; p:=p^.link; dispara(p2); n:=n+1];
  178.   mail_close(h);
  179.   copylst(pbi,str); concat(str,q[wx].pm^.letter);
  180.   h:=mail_zopen(str); {INDEX}
  181.   if h<=0 then [q[wx].dos_err:=-h; dbp_pubmail:=false; return];
  182.   fillc(adr index_buffer,index_length,' ');
  183.   eval(encode(str,q[wx].pm^.next_slot:10)); copystr(str,index_buffer.fptr);
  184.   eval(encode(str,n:5)); copystr(str,index_buffer.mlen);
  185.   index_buffer.deleted[1]:=d;
  186.   copylst(q[wx].my.name,str); cat(str,q[wx].my.userid);
  187.   kopystr(str,index_buffer.msg_from);
  188.   if q[wx].msg_to=nill
  189.     then kopystr(null,index_buffer.msg_to)
  190.     else kopystr(q[wx].msg_to^.msg,index_buffer.msg_to);
  191.   copystr(mydate,index_buffer.date);
  192.   copystr(mytime,index_buffer.time);
  193.   movel(adr index_buffer,adr str[1],index_length); str[0]:=chr(index_length);
  194.   mail_writeln(h,str);
  195.   mail_close(h);
  196.   copystr(index_buffer.date,q[wx].pm^.date);
  197.   copystr(index_buffer.time,q[wx].pm^.time);
  198.   q[wx].pm^.next_slot:=q[wx].pm^.next_slot+n;
  199.   q[wx].pm^.msgs:=q[wx].pm^.msgs+1;
  200.   dbp_pubmail:=true;
  201. end {dbp_pubmail};
  202.  
  203. function dbg_pubmail{vars p : para; dex : integer} {char};
  204. var
  205.   str : lstring(screen_cols);
  206.   i,j,n : integer;
  207.   p2,p3 : para;
  208.   i4 : integer4;
  209. begin
  210.   p:=nill;
  211.   copylst(pbi,str); concat(str,q[wx].pm^.letter);
  212.   f_index.mode:=direct; f_index.trap:=true; f_index.errs:=0;
  213.   assign(f_index,str); reset(f_index); seek(f_index,dex);
  214.   readln(f_index,index_internal_buffer);
  215.   movel(adr index_internal_buffer,adr index_buffer,index_length);
  216.   close(f_index);
  217.   if (f_index.errs<>0) then [dbg_pubmail:='D'; return];
  218.   if index_buffer.deleted<>' ' then
  219.     [dbg_pubmail:=index_buffer.deleted[1]; return];
  220.   copylst(pbd,str); concat(str,q[wx].pm^.letter);
  221.   f_data.mode:=direct; f_data.trap:=true; f_data.errs:=0;
  222.   assign(f_data,str); reset(f_data);
  223.   copylst(index_buffer.fptr,str);
  224.   if decode(str,i4) then seek(f_data,i4);
  225.   if q[wx].flag {scanning} then
  226.     n:=4
  227.   else
  228.     [n:=ivalue(index_buffer.mlen);
  229.      if n>(4*msg_line_limit) then n:=msg_line_limit];
  230.   fSmall:=true; {don't waste heap space - we'll never edit these}
  231.   for i:=1 to n do begin
  232.     if f_data.errs<>0 then break;
  233.     readln(f_data,str);
  234.     for j:=ord(str.len) downto 1 do
  235.       if str[j]=' ' then str.len:=wrd(j-1) else break;
  236.     p3:=newpara(str);
  237.     if p=nill
  238.       then [p:=p3; p2:=p3]
  239.       else [p2^.link:=p3; p2:=p3];
  240.   end {for};
  241.   fSmall:=false;
  242.   close(f_data);
  243.   dbg_pubmail:=' ';
  244. end {dbg_pubmail};
  245.  
  246. procedure dbg_pubindex{dex : integer};
  247. var
  248.   str : lstring(screen_cols);
  249. begin
  250.   copylst(pbi,str); concat(str,q[wx].pm^.letter);
  251.   f_index.mode:=direct; f_index.trap:=true; f_index.errs:=0;
  252.   assign(f_index,str); reset(f_index); seek(f_index,dex);
  253.   readln(f_index,index_internal_buffer);
  254.   movel(adr index_internal_buffer,adr index_buffer,index_length);
  255.   close(f_index);
  256. end {dbg_pubindex};
  257.  
  258. {extract file number from name/number pair}
  259. function get_num(var str : lstring) : integer;
  260. var
  261.   i,ii,j : integer;
  262. begin
  263.   ii:=0;
  264.   for i:=ord(str.len) downto 1 do if str[i]<>' ' then [ii:=i; break];
  265.   for j